home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / unix.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-21  |  16.1 KB  |  651 lines
  1. /*
  2.  *
  3.  * u n i x . c                    -- Some Unix primitives
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: 29-Mar-1994 10:57
  22.  * Last file update: 21-Jul-1996 17:22
  23.  */
  24. #ifndef WIN32
  25. #  include <unistd.h>
  26. #  include <pwd.h>
  27. #else
  28. #  include <io.h>
  29. #  define F_OK   00
  30. #  define X_OK   01
  31. #  define W_OK   02
  32. #  define R_OK   04
  33. #endif
  34.  
  35. #include <sys/types.h>
  36. #include <sys/stat.h>
  37. #include <dirent.h>
  38.  
  39. #ifdef WIN32
  40.    /* One of above files includes <stdarg.h> with BC++  (and stdarg and 
  41.     * vararg are not compatible 
  42.     */
  43. #  undef __STDARG_H 
  44. #endif
  45.  
  46. #include "stk.h"
  47.  
  48.  
  49. #ifdef SUNOS4
  50. /* I avoid to use the POSIX getcwd since it is implemented using popen(3) and
  51.  * pwd(1) on SunOS 4.1.3 ==> It is VERY SLOW.
  52.  */
  53.  
  54. #define getcwd my_getcwd
  55. static char *my_getcwd(char *path, int size)
  56. {
  57.   if (!path) path = (char *) must_malloc(size);
  58.   getwd(path);
  59.   return path;
  60. }
  61. #endif  /* SUNOS4 */
  62.  
  63. /******************************************************************************
  64.  *
  65.  * Utilities
  66.  *
  67.  ******************************************************************************/
  68.  
  69. /*
  70.  * TILDE-EXPAND        -- expand '~' and '~user' string prefix
  71.  *
  72.  */
  73.  
  74. static char *tilde_expand(char *name, char *result)
  75. {
  76.   char *dir, *p;
  77.  
  78. #ifdef WIN32
  79.   strcpy(result, name);
  80.   return name;    
  81. #else
  82.   if (name[0] != '~') {
  83.     strcpy(result, name);
  84.     return name;
  85.   }
  86.  
  87.   if ((name[1] == '/') || (name[1] == '\0')) {
  88.     dir = getenv("HOME");
  89.     if (dir == NULL)
  90.       Err("couldn't find HOME environment for expanding ", STk_makestring(name));
  91.     
  92.     sprintf(result, "%s%s", dir, name+1);
  93.   } 
  94.   else {
  95.     struct passwd *pwPtr;
  96.     register int len;
  97.     for (p=&name[1]; (*p != 0) && (*p != '/'); p++) {
  98.       /* Null body;  just find end of name. */
  99.     }
  100.     len = p-(name+1);
  101.     strncpy(result, name+1, len);
  102.     result[len] = '\0';
  103.  
  104.     pwPtr = getpwnam(result);
  105.     if (pwPtr == NULL) {
  106.       endpwent();
  107.       Err("User does not exist", STk_makestring(result));
  108.     }
  109.     sprintf(result, "%s%s", pwPtr->pw_dir, p);
  110.     endpwent();
  111.   }
  112.   return result;
  113. #endif
  114. }
  115.  
  116. /*
  117.  * ABSOLUTE    -- Given a file name, return its (mostly clean) absolute path name
  118.  *
  119.  */
  120. static void absolute(char *s, char *pathname)    
  121. {
  122.   char *p = pathname;
  123.   char *t;
  124.  
  125.   if (!ISABSOLUTE(s)) {
  126.     getcwd(pathname, MAX_PATH_LENGTH);
  127.     p = &pathname[strlen(pathname)];     /* place p at end of pathname */ 
  128.   }
  129.   *p = DIRSEP;
  130.  
  131.   for ( ; *s; s++) {
  132.     t = s;
  133.     switch (*s) {
  134.       case '.' : if (*(s+1)) {
  135.            switch (*++s) {
  136.              case '.' : if (ISDIRSEP(*p) && (*(s+1)=='\0' || 
  137.                              ISDIRSEP(*(s+1)))) {
  138.                           /* We must go back to the parent */
  139.                           if (ISDIRSEP(*p) && p > pathname)    p --;
  140.                   while (p > pathname && !ISDIRSEP(*p)) p--;
  141.                         }
  142.                         else {
  143.                   /* There is a suit of dot. Copy it */
  144.                   for (s = t; *s == '.'; s++) *++p = '.';
  145.                   s -= 1;
  146.                 }
  147.                         break;
  148. #ifdef WIN32
  149.              case '\\':
  150. #endif
  151.              case '/' : if (!ISDIRSEP(*p)) {
  152.                            *++p = '.';
  153.                           *++p = DIRSEP;
  154.                          }
  155.                         break;
  156.              default  : *++p = '.'; *++p = *s; break;
  157.            }
  158.                  }
  159.                  else { /* We have a final (single) dot */
  160.            if (!ISDIRSEP(*p)) *++p = '.';
  161.          }
  162.                  break;
  163. #ifdef WIN32
  164.       case '\\':
  165. #endif
  166.       case '/' : if (!ISDIRSEP(*p)) *++p = DIRSEP; break;
  167.       default  : *++p = *s;
  168.     }
  169.   }
  170.   
  171.   /* Place a \0 at end. If path ends with a "/", delete it */
  172.   if (p == pathname || !ISDIRSEP(*p)) p++;
  173.   *p = '\0';
  174. }
  175.  
  176.  
  177. #define MAXLINK 50    /* Number max of link before declaring we have a loop */
  178.  
  179. SCM STk_resolve_link(char *path, int count)
  180. {
  181. #ifdef WIN32
  182.   return STk_internal_expand_file_name(path);
  183. #else
  184.   char link[MAX_PATH_LENGTH], dst[MAX_PATH_LENGTH], *s, *d=dst;
  185.   int n;
  186.   SCM p;
  187.   
  188.   p  = STk_internal_expand_file_name(path);
  189.   
  190.   for (s=CHARS(p)+1, *d++='/' ;       ; s++, d++) {
  191.     switch (*s) {
  192.       case '\0':
  193.       case '/' : *d = '\0';
  194.     if ((n=readlink(dst, link, MAX_PATH_LENGTH-1)) > 0) {
  195.       link[n] = '\0';
  196.       if (link[0] == '/') 
  197.         /* link is absolute */
  198.         d = dst;
  199.       else {
  200.         /* relative link. Delete last item */
  201.         while (*--d != '/') {
  202.         }
  203.         d += 1;
  204.       }
  205.            
  206.       /* d points the place where the link must be placed */
  207.       if (d - dst + strlen(link) + strlen(s) < MAX_PATH_LENGTH - 1) {
  208.         /* we have enough room */
  209.         sprintf(d, "%s%s", link, s); 
  210.         /* Recurse. Be careful for loops (a->b and b->a) */
  211.         if (count < MAXLINK) 
  212.           return STk_resolve_link(dst, count+1);
  213.       }
  214.       return Ntruth;
  215.     }
  216.     else {
  217.       if (errno != EINVAL) 
  218.         /* EINVAL = file is not a symlink (i.e. it's a true error) */
  219.         return Ntruth;
  220.       else
  221.         if (*s) *d = '/'; 
  222.         else return STk_makestring(dst);               
  223.     }
  224.       default:   *d = *s;
  225.     }
  226.   }
  227. #endif
  228. }
  229.  
  230.    
  231. /*
  232.  *----------------------------------------------------------------------
  233.  *
  234.  * fileglob --
  235.  *      *****                                    ******
  236.  *     ***** This function is an adaptation of the Tcl function DoGlob ******
  237.  *      ***** Adaptated to use true lists rather than string as in Tcl  ******
  238.  *      *****                                    ******
  239.  *    
  240.  *
  241.  *      This recursive procedure forms the heart of the globbing
  242.  *      code.  It performs a depth-first traversal of the tree
  243.  *      given by the path name to be globbed.
  244.  *
  245.  * Results:
  246.  *      The return value is a standard Tcl result indicating whether
  247.  *      an error occurred in globbing.  After a normal return the
  248.  *      result in interp will be set to hold all of the file names
  249.  *      given by the dir and rem arguments.  After an error the
  250.  *      result in interp will hold an error message.
  251.  *
  252.  * Side effects:
  253.  *      None.
  254.  *
  255.  *----------------------------------------------------------------------
  256.  */
  257.  
  258. static SCM fileglob(char *dir, char *rem, SCM result)
  259. /* dir: Name of a directory at which to start glob expansion.  This name
  260.  * is fixed: it doesn't contain any globbing chars. 
  261.  * rem: Path to glob-expand.
  262.  */
  263. {
  264.   /*
  265.    * When this procedure is entered, the name to be globbed may
  266.    * already have been partly expanded by ancestor invocations of
  267.    * fileglob.  The part that's already been expanded is in "dir"
  268.    * (this may initially be empty), and the part still to expand
  269.    * is in "rem".  This procedure expands "rem" one level, making
  270.    * recursive calls to itself if there's still more stuff left
  271.    * in the remainder.
  272.    */
  273.   
  274.   Tcl_DString newName;                /* Holds new name consisting of
  275.                        * dir plus the first part of rem. */
  276.   register char *p;
  277.   register char c;
  278.   char *openBrace, *closeBrace, *name, *dirName;
  279.   int gotSpecial, baseLength;
  280.   struct stat statBuf;
  281.  
  282.   /*
  283.    * Make sure that the directory part of the name really is a
  284.    * directory.  If the directory name is "", use the name "."
  285.    * instead, because some UNIX systems don't treat "" like "."
  286.    * automatically. Keep the "" for use in generating file names,
  287.    * otherwise "glob foo.c" would return "./foo.c".
  288.    */
  289.   
  290.   dirName = (*dir == '\0') ? ".": dir;
  291.   if ((stat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode))
  292.     return result;
  293.  
  294.   Tcl_DStringInit(&newName);
  295.  
  296.   /*
  297.    * First, find the end of the next element in rem, checking
  298.    * along the way for special globbing characters.
  299.    */
  300.   
  301.   gotSpecial = 0;
  302.   openBrace = closeBrace = NULL;
  303.   for (p = rem; ; p++) {
  304.     c = *p;
  305.     if ((c == '\0') || ((openBrace == NULL) && (c == '/'))) break;
  306.     if ((c == '{')  && (openBrace == NULL)) openBrace = p;
  307.     if ((c == '}')  && (openBrace != NULL) && (closeBrace == NULL)) closeBrace = p;
  308.     if ((c == '*') || (c == '[') || (c == '\\') || (c == '?')) gotSpecial = 1;
  309.   }
  310.  
  311.   /*
  312.    * If there is an open brace in the argument, then make a recursive
  313.    * call for each element between the braces.  In this case, the
  314.    * recursive call to fileglob uses the same "dir" that we got.
  315.    * If there are several brace-pairs in a single name, we just handle
  316.    * one here, and the others will be handled in recursive calls.
  317.    */
  318.  
  319.   if (openBrace != NULL) {
  320.     char *element;
  321.     
  322.     if (closeBrace == NULL) {
  323.       Tcl_DStringFree(&newName);      
  324.       Err("unmatched open-brace in file name", NIL);
  325.     }
  326.  
  327.     Tcl_DStringAppend(&newName, rem, openBrace-rem);
  328.     baseLength = newName.length;
  329.     for (p = openBrace; *p != '}'; ) {
  330.       element = p+1;
  331.       for (p = element; ((*p != '}') && (*p != ',')); p++) {}
  332.       Tcl_DStringAppend(&newName, element, p-element);
  333.       Tcl_DStringAppend(&newName, closeBrace+1, -1);
  334.       result = fileglob(dir, newName.string, result);
  335.       newName.length = baseLength;
  336.     }
  337.     goto done;
  338.   }
  339.  
  340.   /*
  341.    * Start building up the next-level name with dir plus a slash if
  342.    * needed to separate it from the next file name.
  343.    */
  344.  
  345.   Tcl_DStringAppend(&newName, dir, -1);
  346.   if ((dir[0] != 0) && (newName.string[newName.length-1] != '/')) {
  347.     Tcl_DStringAppend(&newName, SDIRSEP, 1);
  348.   }
  349.   baseLength = newName.length;
  350.  
  351.   /*
  352.    * If there were any pattern-matching characters, then scan through
  353.    * the directory to find all the matching names.
  354.    */
  355.  
  356.   if (gotSpecial) {
  357.     DIR *d;
  358.     struct dirent *entryPtr;
  359.     char savedChar;
  360.  
  361.     d = opendir(dirName);
  362.     if (d == NULL) {
  363.       Tcl_DStringFree(&newName);
  364.       Err("cannot read directory", STk_makestring(dirName));
  365.     }
  366.  
  367.     /*
  368.      * Temporarily store a null into rem so that the pattern string
  369.      * is now null-terminated.
  370.      */
  371.  
  372.     savedChar = *p;
  373.     *p = 0;
  374.  
  375.     while (1) {
  376.       entryPtr = readdir(d);
  377.       if (entryPtr == NULL) break;
  378.       /*
  379.        * Don't match names starting with "." unless the "." is
  380.        * present in the pattern.
  381.        */
  382.       if ((*entryPtr->d_name == '.') && (*rem != '.')) continue;
  383.  
  384.       if (Tcl_StringMatch(entryPtr->d_name, rem)) {
  385.     newName.length = baseLength;
  386.     Tcl_DStringAppend(&newName, entryPtr->d_name, -1);
  387.     if (savedChar == 0)
  388.       result = Cons(STk_makestring(newName.string), result);
  389.     else {
  390.       result = fileglob(newName.string, p+1, result);
  391.       if (result != TCL_OK) break;
  392.     }
  393.       }
  394.       
  395.     }
  396.     closedir(d);
  397.     *p = savedChar;
  398.     goto done;
  399.   }
  400.  
  401.   /*
  402.    * The current element is a simple one with no fancy features.  Add
  403.    * it to the new name.  If there are more elements still to come,
  404.    * then recurse to process them.
  405.    */
  406.   
  407.   Tcl_DStringAppend(&newName, rem, p-rem);
  408.   if (*p != 0) {
  409.     result = fileglob(newName.string, p+1, result);
  410.     goto done;
  411.   }
  412.  
  413.   /*
  414.    * There are no more elements in the pattern.  Check to be sure the
  415.    * file actually exists, then add its name to the list being formed
  416.    * in main_interp-result.
  417.    */
  418.  
  419.   name = newName.string;
  420.   if (*name == 0) name = ".";
  421.   if (access(name, F_OK) != 0) goto done;
  422.   result = Cons(STk_makestring(name), result);
  423. done:
  424.   Tcl_DStringFree(&newName);
  425.   return result;
  426. }
  427.  
  428. SCM STk_internal_expand_file_name(char *s)
  429. {
  430.   char expanded[2 * MAX_PATH_LENGTH], abs[2 * MAX_PATH_LENGTH];  
  431.   /* Warning: absolute makes no control about path overflow. Hence the "2 *" */
  432.  
  433.   absolute(tilde_expand(s, expanded), abs);
  434.   return STk_makestring(abs);
  435. }
  436.  
  437.  
  438. void STk_whence(char *exec, char *path)
  439. {
  440.   char *p, *q, dir[MAX_PATH_LENGTH];
  441.   struct stat buf;
  442.  
  443.   if (ISABSOLUTE(exec)) {
  444.     strncpy(path, exec, MAX_PATH_LENGTH);
  445.     return;
  446.   }
  447.  
  448. #ifdef FREEBSD 
  449.   /* I don't understand why this is needed */
  450.   if (access(path, X_OK) == 0) {
  451.     stat(path, &buf);
  452.     if (!S_ISDIR(buf.st_mode)) return;
  453.   }  
  454. #endif
  455.  
  456.   p = getenv("PATH");
  457.   while (*p) {
  458.     /* Copy the stuck of path in dir */
  459.     for (q = dir; *p && *p != PATHSEP; p++, q++) *q = *p;
  460.     *q = '\000';
  461.  
  462.     if (!*dir) { 
  463.       /* patch suggested by Erik Ostrom <eostrom@vesuvius.ccs.neu.edu> */
  464.       getcwd(path, MAX_PATH_LENGTH);
  465.       sprintf(path + strlen(path), "%c%s", DIRSEP, exec);
  466.     }
  467.     else
  468.       sprintf(path, "%s%c%s", dir, DIRSEP, exec);
  469.  
  470.     sprintf(path, "%s%c%s", dir, DIRSEP, exec);
  471.     if (access(path, X_OK) == 0) {
  472.       stat(path, &buf);
  473.       if (!S_ISDIR(buf.st_mode)) return;
  474.     }
  475.      
  476.     /* Try next path */
  477.     if (*p) p++;
  478.   }
  479.   /* Not found. Set path to "" */
  480.   path[0] = '\0';
  481. }
  482.  
  483. int STk_dirp(const char *path)
  484. {
  485.   struct stat buf;
  486.  
  487.   if (stat(path, &buf) >= 0) 
  488.     return S_ISDIR(buf.st_mode);
  489.   return FALSE;
  490. }
  491.  
  492.  
  493. /******************************************************************************
  494.  *
  495.  * Primitives
  496.  *
  497.  ******************************************************************************/
  498.  
  499. PRIMITIVE STk_expand_file_name(SCM s)
  500. {
  501.   if (NSTRINGP(s)) Err("expand-file-name: bad string", s);
  502.   return STk_internal_expand_file_name(CHARS(s));
  503. }
  504.  
  505. PRIMITIVE STk_canonical_path(SCM str)
  506. {
  507.   if (NSTRINGP(str)) Err("canonical-path: not a string", str);
  508.   return STk_resolve_link(CHARS(str), 0);
  509. }
  510.  
  511. PRIMITIVE STk_getcwd(void)
  512. {
  513.   
  514.   char *buf = (char *)getcwd(NULL, MAX_PATH_LENGTH);
  515.   SCM z;
  516.  
  517.   if (!buf) Err("getcwd: cannot allocate space", NIL);
  518.   z = STk_makestring(buf);
  519.   free(buf);
  520.  
  521.   return z;
  522. }
  523.  
  524. PRIMITIVE STk_chdir(SCM s)
  525. {
  526.   if (NSTRINGP(s)) Err("chdir: bad string", s);
  527.   
  528.   if (chdir(CHARS(STk_internal_expand_file_name(CHARS(s)))))
  529.     Err("chdir: cannot change directory to", s);
  530.   return UNDEFINED;
  531. }
  532.  
  533. PRIMITIVE STk_getpid(void)
  534. {
  535.   return (STk_makeinteger((int) getpid()));
  536. }
  537.  
  538. PRIMITIVE STk_system(SCM com)
  539. {
  540.   if (NSTRINGP(com)) Err("system: not a string", com);
  541.   return STk_makeinteger(system(CHARS(com)));
  542. }
  543.      
  544. PRIMITIVE STk_getenv(SCM str)
  545. {
  546.   char *tmp;
  547.   if (NSTRINGP(str)) Err("getenv: not a string", str);
  548.   tmp = getenv(CHARS(str));
  549.   return tmp ? STk_makestring(tmp) : Ntruth;
  550. }
  551.  
  552. PRIMITIVE STk_setenv(SCM var, SCM value)
  553. {
  554.   char *s;
  555.   if (NSTRINGP(var)) Err("setenv!: variable is not a string", var);
  556.   if (strchr(CHARS(var), '=')) Err("setenv!: variable contains a '='", var);
  557.   if (NSTRINGP(value)) Err("setenv!: value is not a string", value);
  558.  
  559.   s = malloc(strlen(CHARS(var))+ strlen(CHARS(value)) + 2); /* 2 cause  '=' & \0 */
  560.   sprintf(s, "%s=%s", CHARS(var), CHARS(value));
  561.   putenv(s);
  562.   return UNDEFINED;
  563. }
  564.  
  565.  
  566. /******************************************************************************
  567.  *
  568.  * file-is-xxx? primitives
  569.  *
  570.  ******************************************************************************/
  571.  
  572. static SCM my_access(SCM path, int mode, char *who)
  573. {
  574.   if (NSTRINGP(path)) {
  575.     char buff[100];
  576.     sprintf(buff, "%s: bad string", who);
  577.     Err(buff, path);
  578.   }
  579.   
  580.   return (access(CHARS(path), mode) == 0) ? Truth: Ntruth;
  581. }
  582.  
  583.  
  584. static SCM my_stat(SCM path, int mode, char *who)
  585. {
  586.   struct stat info;
  587.   
  588.   if (NSTRINGP(path)) {
  589.     char buff[100];
  590.     sprintf(buff, "%s: bad string", who);
  591.     Err(buff, path);
  592.   }
  593.  
  594.   if (stat(CHARS(path), &info) != 0) return Ntruth;
  595.  
  596.   switch (mode) {
  597.     case 1: return (S_ISDIR(info.st_mode)) ? Truth : Ntruth;
  598.     case 2: return (S_ISREG(info.st_mode)) ? Truth : Ntruth;
  599.   }
  600. }
  601.  
  602. PRIMITIVE STk_file_is_directoryp(SCM f)
  603. {
  604.   return my_stat(f, 1, "file-is-directory?");
  605. }
  606.  
  607. PRIMITIVE STk_file_is_regularp(SCM f)
  608. {
  609.   return my_stat(f, 2, "file-is-regular?");
  610. }
  611.  
  612. PRIMITIVE STk_file_is_readablep(SCM f)
  613. {
  614.   return my_access(f, R_OK, "file-is-readable?");
  615. }
  616.  
  617. PRIMITIVE STk_file_is_writablep(SCM f)
  618. {
  619.   return my_access(f, W_OK, "file-is-writable?");
  620. }
  621.  
  622. PRIMITIVE STk_file_is_executablep(SCM f)
  623. {
  624.   return my_access(f, X_OK, "file-is-executable?");
  625. }
  626.  
  627. PRIMITIVE STk_file_existp(SCM f)
  628. {
  629.   return my_access(f, F_OK, "file-exists?");
  630. }
  631.  
  632.  
  633. PRIMITIVE STk_file_glob(SCM l, int len) /* len is unused here */
  634. {
  635.   SCM res = NIL;
  636.   char s[2*MAX_PATH_LENGTH];
  637.   
  638.   for ( ; NNULLP(l); l = CDR(l)) {
  639.     if (NSTRINGP(CAR(l))) Err("glob: bad string", CAR(l));
  640.     
  641.     tilde_expand(CHARS(CAR(l)), s);
  642.  
  643.     res = STk_append(LIST2(res, 
  644.                (ISDIRSEP(*s)) ? fileglob(SDIRSEP, s+1, NIL) :
  645.                fileglob("", s, NIL)),
  646.              2);
  647.   }
  648.   return res;
  649. }
  650.  
  651.